home *** CD-ROM | disk | FTP | other *** search
/ AmigActive 2 / AACD 2.iso / AACD / Programming / fpc / compiler / types.pas < prev    next >
Pascal/Delphi Source File  |  1998-09-24  |  38KB  |  1,029 lines
  1. {
  2.     $Id: types.pas,v 1.2.2.2 1998/04/27 23:07:02 peter Exp $
  3.     Copyright (C) 1993-98 by Florian Klaempfl
  4.  
  5.     This unit provides some help routines for type handling
  6.  
  7.     This program is free software; you can redistribute it and/or modify
  8.     it under the terms of the GNU General Public License as published by
  9.     the Free Software Foundation; either version 2 of the License, or
  10.     (at your option) any later version.
  11.  
  12.     This program is distributed in the hope that it will be useful,
  13.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  14.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15.     GNU General Public License for more details.
  16.  
  17.     You should have received a copy of the GNU General Public License
  18.     along with this program; if not, write to the Free Software
  19.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  ****************************************************************************
  22. }
  23. unit types;
  24.  
  25.   interface
  26.  
  27.     uses
  28.        objects,cobjects,globals,symtable,tree,aasm;
  29.  
  30.     type
  31.        tmmxtype = (mmxno,mmxu8bit,mmxs8bit,mmxu16bit,mmxs16bit,
  32.                    mmxu32bit,mmxs32bit,mmxfixed16,mmxsingle);
  33.  
  34.     { returns true, if def defines an ordinal type }
  35.     function is_ordinal(def : pdef) : boolean;
  36.  
  37.     { true if p points to an open array def }
  38.     function is_open_array(p : pdef) : boolean;
  39.  
  40.     { returns true, if def defines a signed data type (only for ordinal types) }
  41.     function is_signed(def : pdef) : boolean;
  42.  
  43.     { returns true, if def uses FPU }
  44.     function is_fpu(def : pdef) : boolean;
  45.  
  46.     { true if the return value is in EAX }
  47.     function ret_in_acc(def : pdef) : boolean;
  48.  
  49.     { true if uses a parameter as return value }
  50.     function ret_in_param(def : pdef) : boolean;
  51.  
  52.     { true if a const parameter is too large to copy }
  53.     function dont_copy_const_param(def : pdef) : boolean;
  54.     { true if we must never copy this parameter }
  55.     const
  56.        never_copy_const_param : boolean = false;
  57.  
  58.     { true, if def1 and def2 are semantical the same }
  59.     function is_equal(def1,def2 : pdef) : boolean;
  60.  
  61.     { checks for type compatibility (subgroups of type)  }
  62.     { used for case statements... probably missing stuff }
  63.     { to use on other types                              }
  64.     function is_subequal(def1, def2: pdef): boolean;
  65.  
  66.     { true, if two parameter lists are equal }
  67.     function equal_paras(def1,def2 : pdefcoll) : boolean;
  68.  
  69.     { gibt den ordinalen Werten der Node zurueck oder falls sie }
  70.     { keinen ordinalen Wert hat, wird ein Fehler erzeugt        }
  71.     function get_ordinal_value(p : ptree) : longint;
  72.  
  73.     { if l isn't in the range of def a range check error is generated }
  74.     procedure testrange(def : pdef;l : longint);
  75.  
  76.     { returns the range of def }
  77.     procedure getrange(def : pdef;var l : longint;var h : longint);
  78.  
  79.     { generates a VMT for _class }
  80.     procedure genvmt(_class : pobjectdef);
  81.  
  82.     { true, if p is a pointer to a const int value }
  83.     function is_constintnode(p : ptree) : boolean;
  84.  
  85.     { like is_constintnode }
  86.     function is_constboolnode(p : ptree) : boolean;
  87.     function is_constrealnode(p : ptree) : boolean;
  88.     function is_constcharnode(p : ptree) : boolean;
  89.  
  90.     { some type helper routines for MMX support }
  91.     function is_mmx_able_array(p : pdef) : boolean;
  92.  
  93.     { returns the mmx type }
  94.     function mmx_type(p : pdef) : tmmxtype;
  95.  
  96.   implementation
  97.  
  98.     uses verbose;
  99.  
  100.     function is_constintnode(p : ptree) : boolean;
  101.  
  102.       begin
  103.          {DM: According to me, an orddef with anysize, is
  104.           a correct constintnode. Anyway I commented changed s32bit check,
  105.           because it caused problems with statements like a:=high(word).}
  106.          is_constintnode:=((p^.treetype=ordconstn) and
  107.            (p^.resulttype^.deftype=orddef) and
  108.            (porddef(p^.resulttype)^.typ in [u8bit,s8bit,u16bit,s16bit,
  109.             u32bit,s32bit,uauto]));
  110.       end;
  111.  
  112.     function is_constcharnode(p : ptree) : boolean;
  113.  
  114.       begin
  115.          is_constcharnode:=((p^.treetype=ordconstn) and
  116.            (p^.resulttype^.deftype=orddef) and
  117.            (porddef(p^.resulttype)^.typ=uchar));
  118.       end;
  119.  
  120.     function is_constrealnode(p : ptree) : boolean;
  121.  
  122.       begin
  123.          is_constrealnode:=(p^.treetype=realconstn);
  124.       end;
  125.  
  126.     function is_constboolnode(p : ptree) : boolean;
  127.  
  128.       begin
  129.          is_constboolnode:=((p^.treetype=ordconstn) and
  130.            (p^.resulttype^.deftype=orddef) and
  131.            (porddef(p^.resulttype)^.typ=bool8bit));
  132.       end;
  133.  
  134.     function equal_paras(def1,def2 : pdefcoll) : boolean;
  135.  
  136.       begin
  137.          while (assigned(def1)) and (assigned(def2)) do
  138.            begin
  139.               if not(is_equal(def1^.data,def2^.data)) or
  140.                  (def1^.paratyp<>def2^.paratyp) then
  141.                 begin
  142.                    equal_paras:=false;
  143.                    exit;
  144.                 end;
  145.               def1:=def1^.next;
  146.               def2:=def2^.next;
  147.            end;
  148.          if (def1=nil) and (def2=nil) then
  149.            equal_paras:=true
  150.          else
  151.            equal_paras:=false;
  152.       end;
  153.  
  154.     { returns true, if def uses FPU }
  155.     function is_fpu(def : pdef) : boolean;
  156.       begin
  157.          is_fpu:=(def^.deftype=floatdef) and (pfloatdef(def)^.typ<>f32bit);
  158.       end;
  159.     function is_ordinal(def : pdef) : boolean;
  160.  
  161.       var
  162.          dt : tbasetype;
  163.  
  164.       begin
  165.          case def^.deftype of
  166.             orddef : begin
  167.                           dt:=porddef(def)^.typ;
  168.                           is_ordinal:=(dt=s32bit) or (dt=u32bit) or (dt=uchar) or (dt=u8bit) or
  169.                             (dt=s8bit) or (dt=s16bit) or (dt=bool8bit) or (dt=u16bit);
  170.                        end;
  171.             enumdef : is_ordinal:=true;
  172.             else is_ordinal:=false;
  173.          end;
  174.       end;
  175.  
  176.     function is_signed(def : pdef) : boolean;
  177.  
  178.       var
  179.          dt : tbasetype;
  180.  
  181.       begin
  182.          case def^.deftype of
  183.             orddef : begin
  184.                           dt:=porddef(def)^.typ;
  185.                           is_signed:=(dt=s32bit) or (dt=s8bit) or (dt=s16bit);
  186.                        end;
  187.             enumdef : is_signed:=false;
  188.             else internalerror(1001);
  189.          end;
  190.       end;
  191.  
  192.     { true, if p points to an open array def }
  193.     function is_open_array(p : pdef) : boolean;
  194.  
  195.       begin
  196.          is_open_array:=(p^.deftype=arraydef) and
  197.                  (parraydef(p)^.lowrange=0) and
  198.                  (parraydef(p)^.highrange=-1);
  199.       end;
  200.  
  201.     { true if the return value is in accumulator (EAX for i386), D0 for 68k }
  202.     function ret_in_acc(def : pdef) : boolean;
  203.  
  204.       begin
  205.          ret_in_acc:=(def^.deftype=orddef) or
  206.                      (def^.deftype=pointerdef) or
  207.                      (def^.deftype=enumdef) or
  208.                      (def^.deftype=procvardef) or
  209.                      (def^.deftype=classrefdef) or
  210.                      ((def^.deftype=objectdef) and
  211.                       ((pobjectdef(def)^.options and oois_class)<>0)
  212.                      ) or
  213.                      ((def^.deftype=setdef) and
  214.                       (psetdef(def)^.settype=smallset)) or
  215.                      ((def^.deftype=floatdef) and
  216.                       (pfloatdef(def)^.typ=f32bit));
  217.       end;
  218.  
  219.     { true if uses a parameter as return value }
  220.     function ret_in_param(def : pdef) : boolean;
  221.  
  222.       begin
  223.          ret_in_param:=(def^.deftype=arraydef) or
  224.                        (def^.deftype=stringdef) or
  225.                        ((def^.deftype=objectdef) and
  226.                         ((pobjectdef(def)^.options and oois_class)=0)
  227.                        ) or
  228.                        (def^.deftype=recorddef) or
  229.                        ((def^.deftype=setdef) and
  230.                         (psetdef(def)^.settype<>smallset));
  231.       end;
  232.  
  233.     { true if a const parameter is too large to copy }
  234.     function dont_copy_const_param(def : pdef) : boolean;
  235.  
  236.       begin
  237.          dont_copy_const_param:=(def^.deftype=arraydef) or
  238.                        (def^.deftype=stringdef) or
  239.                        (def^.deftype=objectdef) or
  240.                        (def^.deftype=formaldef) or
  241.                        (def^.deftype=recorddef) or
  242.                        (def^.deftype=formaldef) or
  243.                        ((def^.deftype=setdef) and
  244.                         (psetdef(def)^.settype<>smallset));
  245.       end;
  246.  
  247.     procedure testrange(def : pdef;l : longint);
  248.  
  249.       var
  250.          lv,hv: longint;
  251.  
  252.       begin
  253.          getrange(def,lv,hv);
  254.          if (def^.deftype=orddef) and
  255.             (porddef(def)^.typ=u32bit) then
  256.            begin
  257.               if lv<=hv then
  258.                 begin
  259.                    if (l<lv) or (l>hv) then
  260.                     Message(parser_e_range_check_error);
  261.                 end
  262.               else
  263.                 { this happens with the wrap around problem  }
  264.                 { if lv is positive and hv is over $7ffffff  }
  265.                 { so it seems negative                       }
  266.                 begin
  267.                    if ((l>=0) and (l<lv)) or
  268.                       ((l<0) and (l>hv)) then
  269.                     Message(parser_e_range_check_error);
  270.                 end;
  271.            end
  272.          else if (l<lv) or (l>hv) then
  273.            Message(parser_e_range_check_error);
  274.       end;
  275.  
  276.     procedure getrange(def : pdef;var l : longint;var h : longint);
  277.  
  278.       begin
  279.          if def^.deftype=orddef then
  280.            case porddef(def)^.typ of
  281.               s32bit,s16bit,u16bit,s8bit,u8bit :
  282.                 begin
  283.                    l:=porddef(def)^.von;
  284.                    h:=porddef(def)^.bis;
  285.                 end;
  286.               bool8bit : begin
  287.                             l:=0;
  288.                             h:=1;
  289.                          end;
  290.               uchar : begin
  291.                          l:=0;
  292.                          h:=255;
  293.                       end;
  294.               u32bit : begin
  295.                           { this should work now }
  296.                           l:=porddef(def)^.von;
  297.                           h:=porddef(def)^.bis;
  298.                        end;
  299.            end
  300.          else
  301.            if def^.deftype=enumdef then
  302.              begin
  303.                 l:=0;
  304.                 h:=penumdef(def)^.max;
  305.              end;
  306.       end;
  307.  
  308.     function get_ordinal_value(p : ptree) : longint;
  309.  
  310.       begin
  311.          if p^.treetype=ordconstn then
  312.            get_ordinal_value:=p^.value
  313.          else
  314.            Message(parser_e_ordinal_expected);
  315.       end;
  316.  
  317.     function mmx_type(p : pdef) : tmmxtype;
  318.  
  319.       begin
  320.          mmx_type:=mmxno;
  321.          if is_mmx_able_array(p) then
  322.            begin
  323.               if parraydef(p)^.definition^.deftype=floatdef then
  324.                 case pfloatdef(parraydef(p)^.definition)^.typ of
  325.                   s32real:
  326.                     mmx_type:=mmxsingle;
  327.                   f16bit:
  328.                     mmx_type:=mmxfixed16
  329.                 end
  330.               else
  331.                 case porddef(parraydef(p)^.definition)^.typ of
  332.                    u8bit:
  333.                      mmx_type:=mmxu8bit;
  334.                    s8bit:
  335.                      mmx_type:=mmxs8bit;
  336.                    u16bit:
  337.                      mmx_type:=mmxu16bit;
  338.                    s16bit:
  339.                      mmx_type:=mmxs16bit;
  340.                    u32bit:
  341.                      mmx_type:=mmxu32bit;
  342.                    s32bit:
  343.                      mmx_type:=mmxs32bit;
  344.                 end;
  345.            end;
  346.       end;
  347.  
  348.     function is_mmx_able_array(p : pdef) : boolean;
  349.  
  350.       begin
  351. {$ifdef SUPPORT_MMX}
  352.          if (cs_mmx_saturation in aktswitches) then
  353.            begin
  354.               is_mmx_able_array:=(p^.deftype=arraydef) and
  355.                 (
  356.                  ((parraydef(p)^.definition^.deftype=orddef) and
  357.                   (
  358.                   (parraydef(p)^.lowrange=0) and
  359.                   (parraydef(p)^.highrange=1) and
  360.                   (porddef(parraydef(p)^.definition)^.typ in [u32bit,s32bit])
  361.                   ) or
  362.                   (
  363.                   (parraydef(p)^.lowrange=0) and
  364.                   (parraydef(p)^.highrange=3) and
  365.                   (porddef(parraydef(p)^.definition)^.typ in [u16bit,s16bit])
  366.                   )
  367.                  )
  368.                 ) or
  369.                 (
  370.                  ((parraydef(p)^.definition^.deftype=floatdef) and
  371.                   (
  372.                    (parraydef(p)^.lowrange=0) and
  373.                    (parraydef(p)^.highrange=3) and
  374.                    (pfloatdef(parraydef(p)^.definition)^.typ=f16bit)
  375.                   ) or
  376.                   (
  377.                    (parraydef(p)^.lowrange=0) and
  378.                    (parraydef(p)^.highrange=1) and
  379.                    (pfloatdef(parraydef(p)^.definition)^.typ=s32real)
  380.                   )
  381.                  )
  382.                 );
  383.            end
  384.          else
  385.            begin
  386.               is_mmx_able_array:=(p^.deftype=arraydef) and
  387.                 (
  388.                  ((parraydef(p)^.definition^.deftype=orddef) and
  389.                   (
  390.                   (parraydef(p)^.lowrange=0) and
  391.                   (parraydef(p)^.highrange=1) and
  392.                   (porddef(parraydef(p)^.definition)^.typ in [u32bit,s32bit])
  393.                   ) or
  394.                   (
  395.                   (parraydef(p)^.lowrange=0) and
  396.                   (parraydef(p)^.highrange=3) and
  397.                   (porddef(parraydef(p)^.definition)^.typ in [u16bit,s16bit])
  398.                   ) or
  399.                   (
  400.                   (parraydef(p)^.lowrange=0) and
  401.                   (parraydef(p)^.highrange=7) and
  402.                   (porddef(parraydef(p)^.definition)^.typ in [u8bit,s8bit])
  403.                   )
  404.                  )
  405.                 ) or
  406.                 (
  407.                  ((parraydef(p)^.definition^.deftype=floatdef) and
  408.                   (
  409.                    (parraydef(p)^.lowrange=0) and
  410.                    (parraydef(p)^.highrange=3) and
  411.                    (pfloatdef(parraydef(p)^.definition)^.typ=f32bit)
  412.                   )
  413.                   or
  414.                   (
  415.                    (parraydef(p)^.lowrange=0) and
  416.                    (parraydef(p)^.highrange=1) and
  417.                    (pfloatdef(parraydef(p)^.definition)^.typ=s32real)
  418.                   )
  419.                  )
  420.                 );
  421.            end;
  422. {$else SUPPORT_MMX}
  423.          is_mmx_able_array:=false;
  424. {$endif SUPPORT_MMX}
  425.       end;
  426.  
  427.     function is_equal(def1,def2 : pdef) : boolean;
  428.  
  429.       var
  430.          b : boolean;
  431.          hd : pdef;
  432.          hp1,hp2 : pdefcoll;
  433.  
  434.       begin
  435.          { both types must exists }
  436.          if not (assigned(def1) and assigned(def2)) then
  437.           begin
  438.             is_equal:=false;
  439.             exit;
  440.           end;
  441.  
  442.          { be sure, that if there is a stringdef, that this is def1 }
  443.          if def2^.deftype=stringdef then
  444.            begin
  445.               hd:=def1;
  446.               def1:=def2;
  447.               def2:=hd;
  448.            end;
  449.          b:=false;
  450.  
  451.          { wenn beide auf die gleiche Definition zeigen sind sie wohl gleich...}
  452.          if def1=def2 then
  453.            b:=true
  454.          else
  455.          { pointer with an equal definition are equal }
  456.            if (def1^.deftype=pointerdef) and (def2^.deftype=pointerdef) then
  457.          { here a problem detected in tabsolutesym }
  458.          { the types can be forward type !!        }
  459.              begin
  460.                 if assigned(def1^.sym) and ((def1^.sym^.properties and sp_forwarddef)<>0) then
  461.                   b:=(def1^.sym=def2^.sym)
  462.                 else
  463.                   b:=is_equal(ppointerdef(def1)^.definition,ppointerdef(def2)^.definition);
  464.              end
  465.          else
  466.          { Grundtypen sind gleich, wenn sie den selben Grundtyp haben, }
  467.          { und wenn noetig den selben Unterbereich haben }
  468.            if (def1^.deftype=orddef) and (def2^.deftype=orddef) then
  469.              begin
  470.                 case porddef(def1)^.typ of
  471.                    u32bit,u8bit,s32bit,s8bit,u16bit,s16bit : begin
  472.                                      if porddef(def1)^.typ=porddef(def2)^.typ then
  473.                                        if (porddef(def1)^.von=porddef(def2)^.von) and
  474.                                           (porddef(def1)^.bis=porddef(def2)^.bis) then
  475.                                            b:=true;
  476.                                   end;
  477.                    uvoid,bool8bit,uchar :
  478.                      b:=porddef(def1)^.typ=porddef(def2)^.typ;
  479.                 end;
  480.              end
  481.          else
  482.            if (def1^.deftype=floatdef) and (def2^.deftype=floatdef) then
  483.              b:=pfloatdef(def1)^.typ=pfloatdef(def2)^.typ
  484.          else
  485.             { strings with the same length are equal }
  486.             if (def1^.deftype=stringdef) and (def2^.deftype=stringdef) and
  487.                (pstringdef(def1)^.len=pstringdef(def2)^.len) then
  488.             b:=true
  489.     { STRING[N] ist equivalent zu ARRAY[0..N] OF CHAR (N<256) }
  490. {
  491.          else if ((def1^.deftype=stringdef) and (def2^.deftype=arraydef)) and
  492.               (parraydef(def2)^.definition^.deftype=orddef) and
  493.               (porddef(parraydef(def1)^.definition)^.typ=uchar) and
  494.               (parraydef(def2)^.lowrange=0) and
  495.               (parraydef(def2)^.highrange=pstringdef(def1)^.len) then
  496.               b:=true }
  497.           else
  498.             if (def1^.deftype=formaldef) and (def2^.deftype=formaldef) then
  499.               b:=true
  500.           { file types with the same file element type are equal }
  501.           { this is a problem for assign !!                      }
  502.           { changed to allow if one is untyped                   }
  503.           { all typed files are equal to the special             }
  504.           { typed file that has voiddef as elemnt type           }
  505.           { but must NOT match for text file !!!                 }
  506.           else
  507.             if (def1^.deftype=filedef) and (def2^.deftype=filedef) then
  508.               b:=(pfiledef(def1)^.filetype=pfiledef(def2)^.filetype) and
  509.                  ((
  510.                  ((pfiledef(def1)^.typed_as=nil) and
  511.                   (pfiledef(def2)^.typed_as=nil)) or
  512.                  (
  513.                   (pfiledef(def1)^.typed_as<>nil) and
  514.                   (pfiledef(def2)^.typed_as<>nil) and
  515.                   is_equal(pfiledef(def1)^.typed_as,pfiledef(def2)^.typed_as)
  516.                  ) or
  517.                  ( (pfiledef(def1)^.typed_as=pdef(voiddef)) or
  518.                    (pfiledef(def2)^.typed_as=pdef(voiddef))
  519.                  )))
  520.           { sets with the same element type are equal }
  521.           else
  522.             if (def1^.deftype=setdef) and (def2^.deftype=setdef) then
  523.               begin
  524.                  if assigned(psetdef(def1)^.setof) and
  525.                     assigned(psetdef(def2)^.setof) then
  526.                    b:=is_equal(psetdef(def1)^.setof,psetdef(def2)^.setof)
  527.                  else b:=true;
  528.               end
  529.           else
  530.             if (def1^.deftype=procvardef) and (def2^.deftype=procvardef) then
  531.               begin
  532.                  { poassembler isn't important for compatibility }
  533.                  b:=((pprocvardef(def1)^.options and not(poassembler))=
  534.                      (pprocvardef(def2)^.options and not(poassembler))
  535.                     ) and
  536.                    is_equal(pprocvardef(def1)^.retdef,pprocvardef(def2)^.retdef);
  537.                  { now evalute the parameters }
  538.                  if b then
  539.                    begin
  540.                       hp1:=pprocvardef(def1)^.para1;
  541.                       hp2:=pprocvardef(def1)^.para1;
  542.                       while assigned(hp1) and assigned(hp2) do
  543.                         begin
  544.                            if not(is_equal(hp1^.data,hp2^.data)) or
  545.                              not(hp1^.paratyp=hp2^.paratyp) then
  546.                              begin
  547.                                 b:=false;
  548.                                 break;
  549.                              end;
  550.                            hp1:=hp1^.next;
  551.                            hp2:=hp2^.next;
  552.                         end;
  553.                       b:=(hp1=nil) and (hp2=nil);
  554.                    end;
  555.               end
  556.           else
  557.             if (def1^.deftype=arraydef) and (def2^.deftype=arraydef) and
  558.               (is_open_array(def1) or is_open_array(def2)) then
  559.               begin
  560.                  b:=is_equal(parraydef(def1)^.definition,parraydef(def2)^.definition);
  561.               end
  562.           else
  563.             if (def1^.deftype=classrefdef) and (def2^.deftype=classrefdef) then
  564.               begin
  565.                  { similar to pointerdef: }
  566.                  if assigned(def1^.sym) and ((def1^.sym^.properties and sp_forwarddef)<>0) then
  567.                    b:=(def1^.sym=def2^.sym)
  568.                  else
  569.                    b:=is_equal(pclassrefdef(def1)^.definition,pclassrefdef(def2)^.definition);
  570.               end;
  571.          is_equal:=b;
  572.       end;
  573.  
  574.  
  575.     function is_subequal(def1, def2: pdef): boolean;
  576.     Begin
  577.       if assigned(def1) and assigned(def2) then
  578.       Begin
  579.         is_subequal := FALSE;
  580.         if (def1^.deftype = orddef) and (def2^.deftype = orddef) then
  581.           Begin
  582.             { see p.47 of Turbo Pascal 7.01 manual for the separation of types }
  583.             { range checking for case statements is done with testrange        }
  584.             case porddef(def1)^.typ of
  585.               s32bit,u32bit,u8bit,s8bit,s16bit,u16bit:
  586.                 Begin
  587. { PROBABLE CODE GENERATION BUG HERE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! }
  588. {                   if porddef(def2)^.typ in [s32bit,u32bit,u8bit,s8bit,s16bit,u16bit] then
  589.                      is_subequal := TRUE; }
  590.                     if (porddef(def2)^.typ = s32bit) or
  591.                        (porddef(def2)^.typ = u32bit) or
  592.                        (porddef(def2)^.typ = u8bit) or
  593.                        (porddef(def2)^.typ = s8bit) or
  594.                        (porddef(def2)^.typ = s16bit) or
  595.                        (porddef(def2)^.typ = u16bit) then
  596.                      Begin
  597.                        is_subequal:=TRUE;
  598.                      end;
  599.                 end;
  600.               bool8bit: if porddef(def2)^.typ = bool8bit then is_subequal := TRUE;
  601.               uchar: if porddef(def2)^.typ = uchar then is_subequal := TRUE;
  602.             end;
  603.           end
  604.         else
  605.           Begin
  606.             { I assume that both enumerations are equal when the first }
  607.             { pointers are equal.                                      }
  608.             if (def1^.deftype = enumdef) and (def2^.deftype =enumdef) then
  609.               Begin
  610.                 if penumdef(def1)^.first = penumdef(def2)^.first then
  611.                    is_subequal := TRUE;
  612.               end;
  613.           end;
  614.       end; { endif assigned ... }
  615.     end;
  616.  
  617.     type
  618.        pprocdefcoll = ^tprocdefcoll;
  619.  
  620.        tprocdefcoll = record
  621.           next : pprocdefcoll;
  622.           data : pprocdef;
  623.        end;
  624.  
  625.        psymcoll = ^tsymcoll;
  626.  
  627.        tsymcoll = record
  628.           next : psymcoll;
  629.           name : pstring;
  630.           data : pprocdefcoll;
  631.        end;
  632.  
  633.     var
  634.        wurzel : psymcoll;
  635.        nextvirtnumber : longint;
  636.        _c : pobjectdef;
  637.        has_constructor,has_virtual_method : boolean;
  638.  
  639.     procedure eachsym(sym : psym);{$ifndef FPC}far;{$endif}
  640.  
  641.       var
  642.          procdefcoll : pprocdefcoll;
  643.          hp : pprocdef;
  644.          symcoll : psymcoll;
  645.          _name : string;
  646.          stored : boolean;
  647.  
  648.       begin
  649.          { nur Unterprogrammsymbole werden in die VMT aufgenommen }
  650.          if sym^.typ=procsym then
  651.            begin
  652.               _name:=sym^.name;
  653.               symcoll:=wurzel;
  654.               while assigned(symcoll) do
  655.                 begin
  656.                    { wenn das Symbol in der Liste schon existiert }
  657.                    if _name=symcoll^.name^ then
  658.                      begin
  659.                         { walk thorugh all defs of the symbol }
  660.                         hp:=pprocsym(sym)^.definition;
  661.                         while assigned(hp) do
  662.                           begin
  663.                              { compare with all stored definitions }
  664.                              procdefcoll:=symcoll^.data;
  665.                              stored:=false;
  666.                              while assigned(procdefcoll) do
  667.                                begin
  668.                                   { compare parameters }
  669.                                   if equal_paras(procdefcoll^.data^.para1,hp^.para1) and
  670.                                      (
  671.                                        ((procdefcoll^.data^.options and povirtualmethod)<>0) or
  672.                                        ((hp^.options and povirtualmethod)<>0)
  673.                                      ) then
  674.                                     begin
  675.                                        { wenn sie gleich sind }
  676.                                        { und eine davon virtual deklariert ist }
  677.                                        { Fehler falls nur eine VIRTUAL }
  678.                                        if (procdefcoll^.data^.options and povirtualmethod)<>
  679.                                           (hp^.options and povirtualmethod) then
  680.                                             Message1(parser_e_overloaded_are_not_both_virtual,_c^.name^+'.'+_name);
  681.  
  682.                                        { check, if the overridden directive is set }
  683.                                        { (povirtualmethod is set! }
  684.  
  685.                                        { class ? }
  686.                                        if ((_c^.options and oois_class)<>0) and
  687.                                          ((hp^.options and pooverridingmethod)=0) then
  688.                                             Message1(parser_w_should_use_override,_c^.name^+'.'+_name);
  689.  
  690.                                        { error, if the return types aren't equal }
  691.                                        if not(is_equal(procdefcoll^.data^.retdef,hp^.retdef)) then
  692.                                          Message1(parser_e_overloaded_methodes_not_same_ret,_c^.name^+'.'+_name);
  693.  
  694.  
  695.                                        { the flags have to match      }
  696.                                        { except abstract and override }
  697.                                        if (procdefcoll^.data^.options and not(poabstractmethod or pooverridingmethod))<>
  698.                                          (hp^.options and not(poabstractmethod or pooverridingmethod)) then
  699.                                             Message1(parser_e_header_dont_match_forward,_c^.name^+'.'+_name);
  700.  
  701.                                        { now set the number }
  702.                                        hp^.extnumber:=procdefcoll^.data^.extnumber;
  703.                                        { and exchange }
  704.                                        procdefcoll^.data:=hp;
  705.                                        stored:=true;
  706.                                     end;
  707.                                   procdefcoll:=procdefcoll^.next;
  708.                                end;
  709.                              { if it isn't saved in the list }
  710.                              { we create a new entry         }
  711.                              if not(stored) then
  712.                                begin
  713.                                   new(procdefcoll);
  714.                                   procdefcoll^.data:=hp;
  715.                                   procdefcoll^.next:=symcoll^.data;
  716.                                   symcoll^.data:=procdefcoll;
  717.                                   { if the method is virtual ... }
  718.                                   if (hp^.options and povirtualmethod)<>0 then
  719.                                     begin
  720.                                        { ... it will get a number }
  721.                                        hp^.extnumber:=nextvirtnumber;
  722.                                        inc(nextvirtnumber);
  723.                                     end;
  724.                                   { check, if a method should be overridden }
  725.                                   if (hp^.options and pooverridingmethod)<>0 then
  726.                                    Message1(parser_e_nothing_to_be_overridden,_c^.name^+'.'+_name);
  727.                                end;
  728.                              hp:=hp^.nextoverloaded;
  729.                           end;
  730.                         exit;
  731.                      end;
  732.                    symcoll:=symcoll^.next;
  733.                 end;
  734.               { if not, generate a new symbol item }
  735.               new(symcoll);
  736.               symcoll^.name:=stringdup(sym^.name);
  737.               symcoll^.next:=wurzel;
  738.               symcoll^.data:=nil;
  739.               wurzel:=symcoll;
  740.               hp:=pprocsym(sym)^.definition;
  741.  
  742.               { inserts all definitions }
  743.               while assigned(hp) do
  744.                 begin
  745.                    new(procdefcoll);
  746.                    procdefcoll^.data:=hp;
  747.                    procdefcoll^.next:=symcoll^.data;
  748.                    symcoll^.data:=procdefcoll;
  749.  
  750.                    { if it's a virtual method }
  751.                    if (hp^.options and povirtualmethod)<>0 then
  752.                      begin
  753.                         { then it gets a number ... }
  754.                         hp^.extnumber:=nextvirtnumber;
  755.                         { and we inc the number }
  756.                         inc(nextvirtnumber);
  757.                         has_virtual_method:=true;
  758.                      end;
  759.  
  760.                    if (hp^.options and poconstructor)<>0 then
  761.                      has_constructor:=true;
  762.  
  763.                    { check, if a method should be overridden }
  764.                    if (hp^.options and pooverridingmethod)<>0 then
  765.                      Message1(parser_e_nothing_to_be_overridden,_c^.name^+'.'+_name);
  766.                    { next overloaded method }
  767.                    hp:=hp^.nextoverloaded;
  768.                 end;
  769.            end;
  770.       end;
  771.  
  772.     procedure genvmt(_class : pobjectdef);
  773.  
  774.       procedure do_genvmt(p : pobjectdef);
  775.  
  776.         begin
  777.            { start with the base class }
  778.            if assigned(p^.childof) then
  779.              do_genvmt(p^.childof);
  780.  
  781.            { walk through all public syms }
  782.            _c:=_class;
  783. {$ifdef tp}
  784.            p^.publicsyms^.foreach(eachsym);
  785. {$else}
  786.            p^.publicsyms^.foreach(@eachsym);
  787. {$endif}
  788.         end;
  789.  
  790.       var
  791.          symcoll : psymcoll;
  792.          procdefcoll : pprocdefcoll;
  793.          i : longint;
  794.  
  795.       begin
  796.          wurzel:=nil;
  797.          nextvirtnumber:=0;
  798.  
  799.          has_constructor:=false;
  800.          has_virtual_method:=false;
  801.  
  802.          { generates a tree of all used methods }
  803.          do_genvmt(_class);
  804.  
  805.          if has_virtual_method and not(has_constructor) then
  806.            begin
  807.               exterror:=strpnew(_class^.name^);
  808.               Message(parser_w_virtual_without_constructor);
  809.            end;
  810.          { generates the VMT }
  811.  
  812.          { walk trough all numbers for virtual methods and search }
  813.          { the method                                             }
  814.          for i:=0 to nextvirtnumber-1 do
  815.            begin
  816.               symcoll:=wurzel;
  817.  
  818.               { walk trough all symbols }
  819.               while assigned(symcoll) do
  820.                 begin
  821.  
  822.                    { walk trough all methods }
  823.                    procdefcoll:=symcoll^.data;
  824.                    while assigned(procdefcoll) do
  825.                      begin
  826.                         { writes the addresses to the VMT }
  827.                         { but only this which are declared as virtual }
  828.                         if procdefcoll^.data^.extnumber=i then
  829.                           begin
  830.                              if (procdefcoll^.data^.options and povirtualmethod)<>0 then
  831.                                begin
  832.                                   { if a method is abstract, then is also the }
  833.                                   { class abstract and it's not allow to      }
  834.                                   { generates an instance                     }
  835.                                   if (procdefcoll^.data^.options and poabstractmethod)<>0 then
  836.                                     begin
  837.                                        _class^.options:=_class^.options or oois_abstract;
  838.                                        datasegment^.concat(new(pai_const,init_symbol('ABSTRACTERROR')));
  839.                                     end
  840.                                   else
  841.                                     begin
  842.                                       datasegment^.concat(new(pai_const,init_symbol(
  843.                                         strpnew(procdefcoll^.data^.mangledname))));
  844.                                       if (procdefcoll^.data^.options and povirtualmethod)<>0 then
  845.                                         maybe_concat_external(procdefcoll^.data^.owner,
  846.                                           procdefcoll^.data^.mangledname);
  847.                                     end;
  848.                                end;
  849.                           end;
  850.                         procdefcoll:=procdefcoll^.next;
  851.                      end;
  852.                    symcoll:=symcoll^.next;
  853.                 end;
  854.            end;
  855.          { disposes the above generated tree }
  856.          symcoll:=wurzel;
  857.          while assigned(symcoll) do
  858.            begin
  859.               wurzel:=symcoll^.next;
  860.               stringdispose(symcoll^.name);
  861.               procdefcoll:=symcoll^.data;
  862.               while assigned(procdefcoll) do
  863.                 begin
  864.                    symcoll^.data:=procdefcoll^.next;
  865.                    dispose(procdefcoll);
  866.                    procdefcoll:=symcoll^.data;
  867.                 end;
  868.               dispose(symcoll);
  869.               symcoll:=wurzel;
  870.            end;
  871.       end;
  872.  
  873. end.
  874. {
  875.   $Log: types.pas,v $
  876.   Revision 1.2.2.2  1998/04/27 23:07:02  peter
  877.     * small message fixes
  878.  
  879.   Revision 1.2.2.1  1998/04/08 11:38:44  peter
  880.     * nasm patches, pierres symtable patch
  881.  
  882.   Revision 1.2  1998/03/28 23:09:57  florian
  883.     * secondin bugfix (m68k and i386)
  884.     * overflow checking bugfix (m68k and i386) -- pretty useless in
  885.       secondadd, since everything is done using 32-bit
  886.     * loading pointer to routines hopefully fixed (m68k)
  887.     * flags problem with calls to RTL internal routines fixed (still strcmp
  888.       to fix) (m68k)
  889.     * #ELSE was still incorrect (didn't take care of the previous level)
  890.     * problem with filenames in the command line solved
  891.     * problem with mangledname solved
  892.     * linking name problem solved (was case insensitive)
  893.     * double id problem and potential crash solved
  894.     * stop after first error
  895.     * and=>test problem removed
  896.     * correct read for all float types
  897.     * 2 sigsegv fixes and a cosmetic fix for Internal Error
  898.     * push/pop is now correct optimized (=> mov (%esp),reg)
  899.  
  900.   Revision 1.1.1.1  1998/03/25 11:18:15  root
  901.   * Restored version
  902.  
  903.   Revision 1.24  1998/03/21 23:59:40  florian
  904.     * indexed properties fixed
  905.     * ppu i/o of properties fixed
  906.     * field can be also used for write access
  907.     * overriding of properties
  908.  
  909.   Revision 1.23  1998/03/20 23:31:35  florian
  910.     * bug0113 fixed
  911.     * problem with interdepened units fixed ("options.pas problem")
  912.     * two small extensions for future AMD 3D support
  913.  
  914.   Revision 1.22  1998/03/10 01:17:30  peter
  915.     * all files have the same header
  916.     * messages are fully implemented, EXTDEBUG uses Comment()
  917.     + AG... files for the Assembler generation
  918.  
  919.   Revision 1.21  1998/03/06 01:09:01  peter
  920.     * removed the conflicts that had occured
  921.  
  922.   Revision 1.20  1998/03/06 00:53:01  peter
  923.     * replaced all old messages from errore.msg, only ExtDebug and some
  924.       Comment() calls are left
  925.     * fixed options.pas
  926.  
  927.   Revision 1.19  1998/03/05 22:40:56  florian
  928.     + warning about missing constructor added
  929.  
  930.   Revision 1.18  1998/03/04 17:34:14  michael
  931.   + Changed ifdef FPK to ifdef FPC
  932.  
  933.   Revision 1.17  1998/03/02 01:49:38  peter
  934.     * renamed target_DOS to target_GO32V1
  935.     + new verbose system, merged old errors and verbose units into one new
  936.       verbose.pas, so errors.pas is obsolete
  937.  
  938.   Revision 1.16  1998/02/13 10:35:55  daniel
  939.   * Made Motorola version compilable.
  940.   * Fixed optimizer
  941.  
  942.   Revision 1.15  1998/02/12 17:19:33  florian
  943.     * fixed to get remake3 work, but needs additional fixes (output, I don't like
  944.       also that aktswitches isn't a pointer)
  945.  
  946.   Revision 1.14  1998/02/12 11:50:52  daniel
  947.   Yes! Finally! After three retries, my patch!
  948.  
  949.   Changes:
  950.  
  951.   Complete rewrite of psub.pas.
  952.   Added support for DLL's.
  953.   Compiler requires less memory.
  954.   Platform units for each platform.
  955.  
  956.   Revision 1.13  1998/02/11 21:56:41  florian
  957.     * bugfixes: bug0093, bug0053, bug0088, bug0087, bug0089
  958.  
  959.   Revision 1.12  1998/02/07 23:05:08  florian
  960.     * once more MMX
  961.  
  962.   Revision 1.11  1998/02/06 10:34:35  florian
  963.     * bug0082 and bug0084 fixed
  964.  
  965.   Revision 1.10  1998/02/05 22:27:07  florian
  966.     * small problems fixed: remake3 should now work
  967.  
  968.   Revision 1.9  1998/02/05 21:54:36  florian
  969.     + more MMX
  970.  
  971.   Revision 1.8  1998/01/31 00:43:37  carl
  972.     - removed in in is_subequal, because the code generator is buggy!
  973.       (instead uses if...)
  974.  
  975.   Revision 1.7  1998/01/16 18:03:21  florian
  976.     * small bug fixes, some stuff of delphi styled constructores added
  977.  
  978.   Revision 1.6  1998/01/11 19:24:35  carl
  979.     + type checking routine (is_subequal) for case statements
  980.  
  981.   Revision 1.5  1998/01/09 23:08:38  florian
  982.     + C++/Delphi styled //-comments
  983.     * some bugs in Delphi object model fixed
  984.     + override directive
  985.  
  986.   Revision 1.4  1998/01/09 16:08:24  florian
  987.     * abstract methods call now abstracterrorproc if they are called
  988.       a class with an abstract method can be create with a class reference else
  989.       the compiler forbides this
  990.  
  991.   Revision 1.3  1998/01/07 00:17:12  michael
  992.   Restored released version (plus fixes) as current
  993.  
  994.   Revision 1.2  1997/11/28 18:14:51  pierre
  995.    working version with several bug fixes
  996.  
  997.   Revision 1.1.1.1  1997/11/27 08:33:03  michael
  998.   FPC Compiler CVS start
  999.  
  1000.  
  1001.   Pre-CVS log:
  1002.  
  1003.   CEC   Carl-Eric Codere
  1004.   FK    Florian Klaempfl
  1005.   PM    Pierre Muller
  1006.   +     feature added
  1007.   -     removed
  1008.   *     bug fixed or changed
  1009.  
  1010.   History:
  1011.       22th september 1997
  1012.          + function dont_copy_const_param added (FK)
  1013.       25th september 1997
  1014.          + is_open_array added (FK)
  1015.          + is_equal handles now also open arrays (FK)
  1016.       2nd october 1997
  1017.          + added then boolean never_copy_const_param for use in typed write
  1018.            where we must push the reference anyway (PM)
  1019.       3rd october 1997:
  1020.          + renamed ret_in_eax to ret_in_acc (for accumulator for port.) (CEC)
  1021.          - removed reference to i386 unit (CEC)
  1022.      25th october 1997:
  1023.          * poassembler isn't important for compatiblity of proc vars (FK)
  1024.       3rd november 1997:
  1025.          + added formaldef type to types where we dont_copy_const_param (PM)
  1026.       20rd november 1997:
  1027.          + added is_fpu function (PM)
  1028. }
  1029.